home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / generic.scm < prev    next >
Text File  |  1992-09-21  |  23KB  |  579 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: generic.scm,v 1.30 1992/09/21 21:27:28 birkholz Exp $
  39.  
  40. ;;;;  Generic Operation Dispatch Mechanism
  41.  
  42. ;;; Uses MIT Scheme 1d-tables to implement method -> param-list
  43. ;;; table lookup.  Portability requires renaming from "1d" to "oned"
  44.  
  45. ;;;; Methods
  46.  
  47. (define param-list-type
  48.   (make-record-type 'dylan-parameter-list
  49.             '(nrequired specializers next? rest? keys)))
  50. (define param-list? (record-predicate param-list-type))
  51. (define param-list.nrequired (record-accessor param-list-type 'nrequired))
  52. (define param-list.specializers (record-accessor param-list-type 'specializers))
  53. (define param-list.next? (record-accessor param-list-type 'next?))
  54. (define param-list.rest? (record-accessor param-list-type 'rest?))
  55. (define param-list.keys (record-accessor param-list-type 'keys))
  56.  
  57. (define make-param-list
  58.   (let ((makeit (record-constructor param-list-type)))
  59.     (lambda (required next? rest? keys)
  60.       (let ((required (guarantee-symbol-and-specializer-list required)))
  61.     (makeit (length required)
  62.         (map cadr required)
  63.         (guarantee-boolean next?)
  64.         (guarantee-boolean rest?)
  65.         (guarantee-keys keys))))))
  66.  
  67. (define (guarantee-symbol-and-specializer-list original-list)
  68.   (if (all? (lambda (elt)
  69.           (and (pair? elt) (pair? (cdr elt)) (null? (cddr elt))
  70.            (symbol? (car elt))
  71.            (or (class? (cadr elt))
  72.                (singleton? (cadr elt)))))
  73.         original-list)
  74.       original-list
  75.       (guarantee-symbol-and-specializer-list
  76.        (dylan-call dylan:error
  77.            "invalid param-list"
  78.            original-list))))
  79.  
  80. (define (guarantee-keys keys)
  81.   (cond ((not keys) #F)
  82.     ((not (pair? keys)) '#())
  83.     ((all? keyword? keys) keys)
  84.     (else (guarantee-keys
  85.            (dylan-call dylan:error
  86.                "invalid keywords" keys)))))
  87.  
  88. (define (guarantee-boolean bool)
  89.   (if bool #T #F))
  90.  
  91. (define (guarantee-integer object)
  92.   (if (integer? object)
  93.       object
  94.       (guarantee-integer (dylan-call dylan:error "not an integer" object))))
  95.  
  96. (define *method-data* (make-OneD-table))
  97.  
  98. (define (method-data method)
  99.   (let ((data (OneD-table/get *method-data* method #F)))
  100.     (if (not data)
  101.     (dylan-call dylan:error "not a method" method)
  102.     data)))
  103.  
  104. (define (method.param-list method)
  105.   (method-data method))
  106.  
  107. (define (method.specializers method)
  108.   (param-list.specializers (method-data method)))
  109.  
  110. (define (method.nrequired method)
  111.   (param-list.nrequired (method-data method)))
  112.  
  113. (define (method.rest? method)
  114.   (param-list.rest? (method-data method)))
  115.  
  116. (define (method.keys method)
  117.   (param-list.keys (method-data method)))
  118.  
  119. (define (dylan::method? method)
  120.   (if (OneD-table/get *method-data* method #F)
  121.       #T
  122.       #F))
  123.  
  124. (define (dylan::make-method param-list method)
  125.   (OneD-table/put! *method-data* method (guarantee-param-list param-list))
  126.   method)
  127.  
  128. (define (guarantee-param-list param-list)
  129.   (if (param-list? param-list)
  130.       param-list
  131.       (guarantee-param-list
  132.        (dylan-call dylan:error "not a param-list" param-list))))
  133.  
  134. ;;;; Generic Functions
  135.  
  136. (define generic-function-data-type
  137.   (make-record-type 'dylan-generic-function-data
  138.             '(name nrequired keys rest? methods read-only?)))
  139.  
  140. (define generic-function-data.nrequired
  141.   (record-accessor generic-function-data-type 'nrequired))
  142. (define generic-function-data.keys
  143.   (record-accessor generic-function-data-type 'keys))
  144. (define generic-function-data.rest?
  145.   (record-accessor generic-function-data-type 'rest?))
  146. (define generic-function-data.methods
  147.   (record-accessor generic-function-data-type 'methods))
  148. (define set-generic-function-data.methods!
  149.   (record-updater generic-function-data-type 'methods))
  150. (define generic-function-data.read-only?
  151.   (record-accessor generic-function-data-type 'read-only?))
  152. (define set-generic-function-data.read-only?!
  153.   (record-updater generic-function-data-type 'read-only?))
  154. (define make-generic-function-data
  155.   (record-constructor generic-function-data-type))
  156.  
  157. (define *generic-function-data* (make-OneD-table))
  158.  
  159. (define (generic-function-data fn)
  160.   (let ((data (OneD-table/get *generic-function-data* fn #F)))
  161.     (if (not data)
  162.     (dylan-call dylan:error "not a generic function" fn)
  163.     data)))
  164.  
  165. (define (generic-function.nrequired generic-function)
  166.   (generic-function-data.nrequired (generic-function-data generic-function)))
  167.  
  168. (define (generic-function.keys generic-function)
  169.   (generic-function-data.keys (generic-function-data generic-function)))
  170.  
  171. (define (generic-function.rest? generic-function)
  172.   (generic-function-data.rest? (generic-function-data generic-function)))
  173.  
  174. (define (generic-function.methods generic-function)
  175.   (generic-function-data.methods (generic-function-data generic-function)))
  176.  
  177. (define (generic-function.read-only? generic-function)
  178.   (generic-function-data.read-only? (generic-function-data generic-function)))
  179.  
  180. (define (set-generic-function.read-only?! generic-function read-only?)
  181.   (set-generic-function-data.read-only?!
  182.    (generic-function-data generic-function) (if read-only? #T #F)))
  183.  
  184. (define (find-method generic-function specializers)
  185.   (let loop ((methods (generic-function.methods generic-function)))
  186.     (if (pair? methods)
  187.     (if (specializers=? specializers
  188.                 (method.specializers (car methods)))
  189.         (car methods)
  190.         (loop (cdr methods)))
  191.     #F)))
  192.  
  193. (define delete-method!
  194.   (letrec ((delete-pair!
  195.         (lambda (pair list)
  196.           (if (eq? pair list)
  197.           (cdr list)
  198.           (let loop ((pairs list))
  199.             (if (pair? pairs)
  200.             (if (eq? pair (cdr pairs))
  201.                 (begin 
  202.                   (set-cdr! pairs (cddr pairs))
  203.                   list)
  204.                 (loop (cdr pairs)))
  205.             list))))))
  206.     (lambda (generic-function method)
  207.       (let* ((data (generic-function-data generic-function))
  208.          (pair (memq method (generic-function-data.methods data))))
  209.     (if (not pair)
  210.         (dylan-call dylan:error
  211.             "method not in generic function"
  212.             method generic-function)
  213.         (set-generic-function-data.methods!
  214.          data (delete-pair! pair (generic-function-data.methods data)))))
  215.       method)))
  216.  
  217. (define (Add-Method generic-function method . multi-value-receiver)
  218.   (let ((data (generic-function-data generic-function))
  219.     (param-list (method.param-list method)))
  220.     (define (congruency-error)
  221.       (cond
  222.        ((not (= (param-list.nrequired param-list)
  223.         (generic-function-data.nrequired data)))
  224.     "required argument count mismatch")
  225.        ((and (not (or (generic-function-data.rest? data)
  226.               (generic-function-data.keys data)))
  227.          (or (param-list.rest? param-list)
  228.          (param-list.keys param-list)))
  229.     "generic function doesn't allow rest/keys")
  230.        ((and (or (generic-function-data.rest? data)
  231.          (generic-function-data.keys data))
  232.          (not (or (param-list.rest? param-list)
  233.               (param-list.keys param-list))))
  234.     "generic function requires rest/keys")
  235.        (else #F)))
  236.     (cond ((generic-function-data.read-only? data)
  237.        (dylan-call dylan:error
  238.                "add-method -- generic function is read-only"
  239.                generic-function))
  240.       ((and (pair? (generic-function-data.keys data))
  241.         (not (let ((method-keys (param-list.keys param-list)))
  242.                (or (param-list.rest? param-list)
  243.                (and method-keys (not (pair? method-keys)))
  244.                (subset? (generic-function-data.keys data)
  245.                     method-keys)))))
  246.        (dylan-call dylan:error
  247.                "add-method -- generic function requires certain keys"
  248.                (generic-function-data.keys data)))
  249.       ((congruency-error)
  250.        =>
  251.        (lambda (specific-error)
  252.          (dylan-call dylan:error
  253.              (string-append
  254.               "add-method -- parameter lists not congruent, "
  255.               specific-error)
  256.              generic-function method))))
  257.     (let ((old-method (find-method generic-function
  258.                    (method.specializers method))))
  259.       (if old-method
  260.       (delete-method! generic-function old-method))
  261.       (set-generic-function-data.methods!
  262.        data (cons method (generic-function-data.methods data)))
  263.       (if (not (null? multi-value-receiver))
  264.       ((car multi-value-receiver) method old-method)
  265.       old-method))))
  266.  
  267. (define (dylan::generic-function? obj)
  268.   (if (OneD-table/get *generic-function-data* obj #F) #T #F))
  269.  
  270. (define (dylan::create-generic-function name nrequired keys rest?)
  271.   (letrec ((data
  272.         (make-generic-function-data name
  273.                     (guarantee-integer nrequired)
  274.                     (guarantee-keys keys)
  275.                     (guarantee-boolean rest?)
  276.                     '() #F))
  277.        (generic-function
  278.         (lambda args
  279.           (generic-dispatch (car args) (cddr args) generic-function data))))
  280.     (OneD-table/put! *generic-function-data* generic-function data)
  281.     generic-function))
  282.  
  283. ;;;; Generic Dispatch
  284.  
  285. (define (generic-dispatch multiple-values original-args generic-function data)
  286.   (let ((nreq (generic-function-data.nrequired data))
  287.     (ngiven (length original-args)))
  288.     (if (> nreq ngiven)
  289.     (dylan-call dylan:error
  290.             "generic-dispatch -- too few arguments supplied"
  291.             nreq original-args))
  292.     (let ((applicable-methods
  293.        (sorted-applicable-methods
  294.         (generic-function-data.methods data)
  295.         original-args))
  296.       (non-req-args (but-first nreq original-args)))
  297.       (if (not (pair? applicable-methods))
  298.       (dylan-call dylan:error
  299.               "generic-dispatch -- no applicable methods"
  300.               generic-function original-args))
  301.       (if (> ngiven nreq)        ; More supplied than required
  302.       (if (or (generic-function-data.keys data)
  303.           (generic-function-data.rest? data))
  304.           (check-handled-keywords non-req-args applicable-methods)
  305.           (dylan-call dylan:error
  306.               "generic-dispatch -- too many arguments supplied"
  307.               generic-function nreq original-args)))
  308.       (let next-method-loop ((remaining-methods applicable-methods)
  309.                  (multiple-values multiple-values)
  310.                  (current-args original-args))
  311.     (apply (car remaining-methods)
  312.            multiple-values
  313.            (if (null? (cdr remaining-methods))
  314.            #F
  315.            (lambda (multiple-values next-method . these-args)
  316.              next-method    ; Ignored
  317.              (next-method-loop (cdr remaining-methods)
  318.                        multiple-values
  319.                        (if (null? these-args)
  320.                        current-args
  321.                        these-args))))
  322.            current-args)))))
  323.  
  324. (define (check-handled-keywords non-req-args methods)
  325.   ;;   gather the keywords for all of the applicable methods
  326.   ;;   if ALL methods specify !rest without !key then the call
  327.   ;;      is allowable
  328.   ;;   if ANY method specifies !rest (or !key with no specific
  329.   ;;      keys), then the call is allowable provided the extra
  330.   ;;      arguments are in keyword/value format
  331.   ;;   otherwise all of the keywords passed must be accepted by
  332.   (define all-!rest? #T)
  333.   (define any-!key? #F)
  334.   (let loop ((keywords '())
  335.          (methods methods))
  336.     (if (pair? methods)
  337.     (let* ((param-list (method.param-list (car methods)))
  338.            (keys (param-list.keys param-list))
  339.            (rest? (param-list.rest? param-list)))
  340.       (if (or (not rest?) keys) (set! all-!rest? #F))
  341.       (cond ((or (param-list.rest? param-list)
  342.              (and keys (not (pair? keys))))
  343.          (set! any-!key? #T))
  344.         ((pair? keys)
  345.          (loop (append keys keywords)
  346.                (cdr methods)))))
  347.     (cond (all-!rest? 'OK)
  348.           (any-!key? (dylan::keyword-validate #T non-req-args #T))
  349.           (else (dylan::keyword-validate #T non-req-args keywords))))))
  350.  
  351. ;;;; Finding and sorting applicable methods.
  352.  
  353. (define (sorted-applicable-methods methods arguments)
  354.   (map cdr                ; Strip specificities.
  355.        (sort (find-applicable-method-specificities methods arguments)
  356.          (lambda (specificities/method-1 specificities/method-2)
  357.            ;; Specificities are handled left-to-right through the list.
  358.            (let loop ((specificities-1 (car specificities/method-1))
  359.               (specificities-2 (car specificities/method-2)))
  360.          (if (and (pair? specificities-1)
  361.               (pair? specificities-2))
  362.              (let ((specificity-1 (car specificities-1))
  363.                (specificity-2 (car specificities-2)))
  364.                (cond ((eq? specificity-1 specificity-2)
  365.                   (loop (cdr specificities-1)
  366.                     (cdr specificities-2)))
  367.                  ((eq? #T specificity-1) #T)
  368.                  ((eq? #T specificity-2) #F)
  369.                  ((> specificity-1 specificity-2) #T)
  370.                  ((< specificity-1 specificity-2) #F)
  371.                  (else
  372.                   (loop (cdr specificities-1)
  373.                     (cdr specificities-2)))))
  374.              #T))))))
  375.  
  376. (define (find-applicable-method-specificities methods arguments)
  377.   ;; Returns a list of (specificities . method) for each applicable method
  378.   ;; in `methods'.  `specificities' is a list containing the specificity of
  379.   ;; each specializer of the method.  If there are no required arguments,
  380.   ;; `specificities' is always the empty list.  If there are no applicable
  381.   ;; methods, the return value is an empty list.
  382.   (let loop ((specificities/method-pairs '())
  383.          (methods methods))
  384.     (if (not (pair? methods))
  385.     specificities/method-pairs
  386.     (let ((method (car methods)))
  387.       (let ((specificities (method-applicable? method arguments)))
  388.         (loop (cond ((eq? #F specificities)
  389.              specificities/method-pairs)
  390.             ((eq? #T specificities)
  391.              (cons (cons '() method) specificities/method-pairs))
  392.             (else (cons (cons specificities method)
  393.                     specificities/method-pairs)))
  394.           (cdr methods)))))))
  395.  
  396. (define (method-applicable? method arguments)
  397.   ;; Returns #F if `method' shouldn't be applied to `arguments'.  Else,
  398.   ;; returns a list of the specificities of the specializers involved in
  399.   ;; the match.  If this list would be empty because there are no required
  400.   ;; parameters, return #T instead.
  401.   (let loop ((remaining-arguments arguments)
  402.          (remaining-specializers (method.specializers method))
  403.          (specificities '()))
  404.     (if (pair? remaining-specializers)
  405.     (if (not (pair? remaining-arguments))
  406.         (dylan-call dylan:error
  407.             "method-applicable? -- too few arguments"
  408.             arguments method)
  409.         (let ((specificity
  410.            (match-specializer? (car remaining-arguments)
  411.                        (car remaining-specializers))))
  412.           (if specificity
  413.           (loop (cdr remaining-arguments) (cdr remaining-specializers)
  414.             (cons specificity specificities))
  415.           #F)))
  416.     ;; MIT-Scheme bogosity.  (eq? #F '()) => #T!!!
  417.     (if (null? specificities)
  418.         #T
  419.         (reverse specificities)))))
  420.  
  421. (define (match-specializer? object specializer)
  422.   ;; Returns #F if `object' doesn't match `specializer'.  Else, returns the
  423.   ;; specificity of the match.  A high specificity indicates a very
  424.   ;; specific match.  A specificity of #t indicates an exact match of a
  425.   ;; singleton.
  426.   (cond ((singleton? specializer)
  427.      (if (Id? object (singleton.object specializer))
  428.          #T
  429.          #F))
  430.     ((class? specializer)
  431.      (if (subclass? (get-type object) specializer)
  432.          (class.specificity specializer)
  433.          #F))
  434.     (else (dylan-call dylan:error
  435.               "match-specializer? -- weird specializer"
  436.               specializer))))
  437.  
  438. (define (specializers=? specializers1 specializers2)
  439.   ;; Returns #T when two lists of specializers contain the same specializer
  440.   ;; in each position.  "same" is `eq?' except for singletons, which are
  441.   ;; not guaranteed to be unique for arbitrary objects (e.g. `3').
  442.   (let loop ((specs1 specializers1)
  443.          (specs2 specializers2))
  444.     (if (and (pair? specs1)
  445.          (pair? specs2))
  446.     (let ((spec1 (car specs1))
  447.           (spec2 (car specs2)))
  448.       (if (or (and (singleton? spec1)
  449.                (singleton? spec2)
  450.                (Id? (singleton.object spec1)
  451.                 (singleton.object spec2)))
  452.           (and (class? spec1)
  453.                (class? spec2)
  454.                (eq? spec1 spec2)))
  455.           (loop (cdr specs1) (cdr specs2))
  456.           #F))
  457.     (if (and (null? specs1)
  458.          (null? specs2))
  459.         #T
  460.         (dylan-call dylan:error
  461.             "specializer list length mismatch"
  462.             specializers1 specializers2)))))
  463.  
  464. ;;; Dylan Calling Conventions
  465.  
  466. (define (make-dylan-callable scheme-operation . n-args)
  467.   ;; Remove the incoming NEXT-METHOD and multiple-value arguments, so
  468.   ;; that a standard Scheme procedure can be called from Dylan
  469.   (if (or (null? n-args) (> (car n-args) 3) (negative? (car n-args)))
  470.       (lambda args (apply scheme-operation (cddr args)))
  471.       (case (car n-args)
  472.     ((0) (lambda (multi next) multi next (scheme-operation)))
  473.     ((1) (lambda (multi next a) multi next (scheme-operation a)))
  474.     ((2) (lambda (multi next a b) multi next (scheme-operation a b)))
  475.     ((3) (lambda (multi next a b c)
  476.            multi next
  477.            (scheme-operation a b c))))))
  478.  
  479. (define (dylan-call dylan-fn . args)
  480.   ;; Fills in the missing multiple-values and next-method parameters.
  481.   ;; This is useful if you do NOT want multiple values back!
  482.   (case (length args)
  483.     ((0) (dylan-fn #F NEXT-METHOD:NOT-GENERIC))
  484.     ((1) (dylan-fn #F NEXT-METHOD:NOT-GENERIC (car args)))
  485.     ((2) (dylan-fn #F NEXT-METHOD:NOT-GENERIC (car args) (cadr args)))
  486.     ((3) (dylan-fn #F NEXT-METHOD:NOT-GENERIC (car args) (cadr args)
  487.            (caddr args)))
  488.     ((4) (dylan-fn #F NEXT-METHOD:NOT-GENERIC (car args) (cadr args)
  489.            (caddr args) (cadddr args)))
  490.     (else (apply dylan-fn #F NEXT-METHOD:NOT-GENERIC args))))
  491.  
  492. (define (dylan-full-call dylan-fn multi-value next-method . args)
  493.   ;; Use this ONLY if you must specify multi-value or next-method
  494.   ;; when calling from Scheme to Dylan.
  495.   (case (length args)
  496.     ((0) (dylan-fn multi-value next-method))
  497.     ((1) (dylan-fn multi-value next-method (car args)))
  498.     ((2) (dylan-fn multi-value next-method (car args) (cadr args)))
  499.     ((3) (dylan-fn multi-value next-method
  500.            (car args) (cadr args) (caddr args)))
  501.     ((4) (dylan-fn multi-value next-method
  502.            (car args) (cadr args) (caddr args) (cadddr args)))
  503.     (else (apply dylan-fn multi-value next-method args))))
  504.  
  505. (define (dylan-mv-call dylan-fn multi-value . args)
  506.   ;; Use this ONLY if you must specify multi-value
  507.   ;; when calling from Scheme to Dylan.
  508.   (case (length args)
  509.     ((0) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC))
  510.     ((1) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC (car args)))
  511.     ((2) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC (car args) (cadr args)))
  512.     ((3) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC
  513.            (car args) (cadr args) (caddr args)))
  514.     ((4) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC
  515.            (car args) (cadr args) (caddr args) (cadddr args)))
  516.     (else (apply dylan-fn multi-value NEXT-METHOD:NOT-GENERIC args))))
  517.  
  518. (define (reformat-apply-args args)
  519.   (split-last args
  520.           (lambda (early end)
  521.         (append early (if (null? end) '() (car end))))))
  522.  
  523. (define (dylan-apply dylan-fn . args)
  524.   ;; Fills in the missing multiple-values and next-method parameters.
  525.   ;; This is useful if you do NOT want multiple values back!
  526.   (let ((args (reformat-apply-args args)))
  527.     (case (length args)
  528.       ((0) (dylan-fn #f NEXT-METHOD:NOT-GENERIC))
  529.       ((1) (dylan-fn #f NEXT-METHOD:NOT-GENERIC (car args)))
  530.       ((2) (dylan-fn #f NEXT-METHOD:NOT-GENERIC (car args) (cadr args)))
  531.       ((3) (dylan-fn #f NEXT-METHOD:NOT-GENERIC
  532.              (car args) (cadr args) (caddr args)))
  533.       ((4) (dylan-fn #f NEXT-METHOD:NOT-GENERIC
  534.              (car args) (cadr args) (caddr args) (cadddr args)))
  535.       (else (apply dylan-fn #f NEXT-METHOD:NOT-GENERIC args)))))
  536.  
  537. (define (dylan-full-apply dylan-fn multi-value next-method . args)
  538.   ;; You must specify the first two arguments (multiple-values and
  539.   ;; next-method) explictly.
  540.   (let ((args (reformat-apply-args args)))
  541.     (case (length args)
  542.       ((0) (dylan-fn multi-value next-method))
  543.       ((1) (dylan-fn multi-value next-method (car args)))
  544.       ((2) (dylan-fn multi-value next-method (car args) (cadr args)))
  545.       ((3) (dylan-fn multi-value next-method
  546.              (car args) (cadr args) (caddr args)))
  547.       ((4) (dylan-fn multi-value next-method
  548.              (car args) (cadr args) (caddr args) (cadddr args)))
  549.       (else (apply dylan-fn multi-value next-method args)))))
  550.  
  551. (define (dylan-mv-apply dylan-fn multi-value . args)
  552.   ;; You must specify the first argument (multiple-values) explictly.
  553.   (let ((args (reformat-apply-args args)))
  554.     (case (length args)
  555.       ((0) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC))
  556.       ((1) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC (car args)))
  557.       ((2) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC (car args)
  558.              (cadr args)))
  559.       ((3) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC
  560.              (car args) (cadr args) (caddr args)))
  561.       ((4) (dylan-fn multi-value NEXT-METHOD:NOT-GENERIC
  562.              (car args) (cadr args) (caddr args) (cadddr args)))
  563.       (else (apply dylan-fn multi-value NEXT-METHOD:NOT-GENERIC args)))))
  564.  
  565. (define (dylan::function->method param-list scheme-function)
  566.   (dylan::make-method
  567.    param-list
  568.    (let ((nreq (param-list.nrequired param-list))
  569.      (rest? (param-list.rest? param-list))
  570.      (keys (param-list.keys param-list)))
  571.      (make-dylan-callable
  572.       scheme-function
  573.       (if (or rest? keys)
  574.       -1                ; Unknown number of arguments
  575.       nreq)))))
  576.  
  577. (define (dylan::dylan-callable->method param-list dylan-callable)
  578.   (dylan::make-method param-list dylan-callable))
  579.